unit SqlUtils;

interface

uses SysUtils, Classes, Db, Windows, Contnrs, IBSQL, IBDatabase, IBCustomDataset;

const
  CMD_SEP_CHARS = '/**/';
  SQL_KEYWORDS: array[0..2] of string = ('SUM', 'COUNT', 'USER');

type
  TCmdType = (ctSelect, ctUpdate, ctInsert, ctDelete, ctDDL, ctUnknown);

  TsmStringList = class(TStringList)
  private
    FDelimiter :Char;
  public
    constructor create;
    property Delimiter :Char read FDelimiter write FDelimiter;
    procedure setDelimText(Value :string);
  end;

  TSqlHistory = class(TObjectList)
  private
  protected
    function GetItem(Index: Integer): TStrings;
    procedure SetItem(Index: Integer; AObject: TStrings);
  public
    function Add(AObject: TStrings): Integer;
    procedure Insert(Index: Integer; AObject: TStrings);
    property Items[Index: Integer]: TStrings read GetItem write SetItem; default;
    //
    function AddText(S: string): integer;
    procedure SaveToFile(FileName: string);
    procedure LoadFromFile(FileName: string);
  end;

  TqIBDataSet = class( TIBDataSet )
  public
    property QSelect;
  end;


function BuildSelect(const TableName: string): string;
function BuildValues(ADataSet: TDataSet; Flds: string; FoxData: boolean = False;
                     AData: TStrings = nil): string;
function BuildFoxValues(ADataSet: TDataSet; Flds: string = ''): string;
procedure BuildInsert(ADataSet: TDataSet; Dest: TStrings);
function CommandType(const Cmd: string): TCmdType;
procedure DelEmptyLines(S: TStrings);
function GetCommaSpaceText(AStrings: TStrings; AQuote: string = ''): string;
function GetFieldDefList(ADataSet: TDataSet): string;

procedure ExtractDataAsSql(Src: TDataSet; DestTable: string;
            OutStrings: TStrings; AdditionalData: string = ''); overload;
procedure ExtractDataAsSql(Src: TDataSet; DestTable: string;
            OutFile: string; AdditionalData: string = ''); overload;
procedure ExtractIbData(Db: TIBDatabase; aSQL: string; DestFile: string);

function ExtractTableName(CommandText: string): string;
procedure LoadSqlHistory(const FileName: string; Dest: TStrings);
procedure SetWhereClause(SQL: TStrings; WhereClause: string);

function IbBuildInsert(q: TIBSQL): string; overload;
function IbBuildInsert(p_ds: TIBDataset): string; overload;
//
function IbBuildUpdate(q: TIBSQL): string; overload;
function IbBuildUpdate(p_ds: TIBDataset): string; overload;
//
function IbGetFieldList(IbSql: TIBSQL): string;


const
  arrBoolVals: array[boolean] of char = ('0', '1');
  FoxBools: array[boolean] of string = ('.F.', '.T.');

implementation

function IbBuildUpdate(q: TIBSQL): string;
var flds, vals: string;
  list: TStringList;
  i: integer;
begin
  result := 'UPDATE ' + ExtractTableName(q.SQL.Text) + ' SET '#13#10;
  if not q.Transaction.InTransaction then
    q.Transaction.StartTransaction;
  q.Params[0].AsString := '-1';
  q.ExecQuery;
  list := TStringList.Create;
  try
    LIST.Text := IbGetFieldList(q);
    for i := 0 to list.Count - 1 do begin
      result := result + '"' + list[i] + '" = :"' + list[i] + '"';
      if i < list.count - 1 then
        result := result + ','#13#10;
    end;
    result := result + ' WHERE ID = :ID';
  finally
    list.Free;
    q.Transaction.Commit;
  end;

end;

function IbBuildUpdate(p_ds: TIBDataset): string;
var q: TIBSQL;
    tr: TIBTransaction;
begin
  q := TIBSQL.Create( p_ds );
  try
    tr := TIBTransaction.Create( q );
    tr.DefaultDatabase := p_ds.Database;
    q.Database := p_ds.DataBase;
    q.Transaction := tr;
    q.SQL.Assign( p_ds.SelectSQL );
    result := IbBuildUpdate( q );
  finally
    q.Free;
  end;
end;

// IbBuildInsert
function IbBuildInsert(q: TIBSQL): string;
var flds, vals: string;
  list: TStringList;
  i: integer;
begin
  result := 'INSERT INTO ' + ExtractTableName(q.SQL.Text) + '(%s) VALUES (%s)';
  if not q.Transaction.InTransaction then
    q.Transaction.StartTransaction;
  q.Params[0].AsString := '-1';
  q.ExecQuery;
  list := TStringList.Create;
  try
    LIST.Text := IbGetFieldList(q);
    for i := 0 to list.Count - 1 do
      list[i] := '"' + list[i] + '"';
    flds := getCommaSpaceText(list);
    for i := 0 to list.Count - 1 do
      list[i] := ':' + list[i];
    vals := getCommaSpaceText(list);
    result := Format(result, [flds, vals]);
  finally
    list.Free;
    q.Transaction.Commit;
  end;
end;

function IbBuildInsert( p_ds: TIBDataset ): string;
var q: TIBSQL;
    tr: TIBTransaction;
begin
  q := TIBSQL.Create( p_ds );
  try
    tr := TIBTransaction.Create( q );
    tr.DefaultDatabase := p_ds.Database;
    q.Database := p_ds.DataBase;
    q.Transaction := tr;
    q.SQL.Assign( p_ds.SelectSQL );
    result := IbBuildInsert( q );
  finally
    q.Free;
  end;
end;

{ TsmStringList }

constructor TsmStringList.create;
begin
  inherited Create;
  FDelimiter:=';';
end;

procedure TsmStringList.setDelimText(Value: string);
var
  P,
  Start :PChar;
  S     :string;
  i    :integer;
begin
  BeginUpdate;
  try
    Clear;
    P := Pointer(Value);
    if P <> nil then
      while P^ <> #0 do
      begin
        Start := P;
        while not (P^ in [#0, FDelimiter]) do Inc(P);
        SetString(S, Start, P - Start);
        Add(S);
        if P^ = FDelimiter then Inc(P);
      end;
    for i:=0 to Count-1 do
      Strings[i]:=Trim(Strings[i]);
  finally
    EndUpdate;
  end;
end;

{ TSqlHistory }

function TSqlHistory.Add(AObject: TStrings): Integer;
begin
  result := inherited Add(AObject);
end;

function TSqlHistory.AddText(S: string): integer;
var sl: TStringList;
begin
  sl := TStringList.Create;
  sl.Text := S;
  result := Add(sl);
end;

function TSqlHistory.GetItem(Index: Integer): TStrings;
begin
  result := TStrings(inherited Items[Index]);
end;

procedure TSqlHistory.Insert(Index: Integer; AObject: TStrings);
begin
  inherited Insert(Index, AObject);
end;

procedure TSqlHistory.LoadFromFile(FileName: string);
var
  sl, NewItem: TStringList;
begin
  sl := TStringList.Create;
  try
    sl.LoadFromFile(FileName);
    while sl.Count > 0 do begin
      NewItem := TStringList.Create;
      while (sl.Count > 0) and (sl[0] <> CMD_SEP_CHARS) do begin
        NewItem.Add(sl[0]);
        sl.Delete(0);
      end;
      Add(NewItem);
      if sl[0] = CMD_SEP_CHARS then sl.Delete(0);
    end;
  finally
    sl.Free;
  end;
end;

procedure TSqlHistory.SaveToFile(FileName: string);
var
  i: integer;
  sl: TStringList;
begin
  sl := TStringList.Create;
  try
    for i := 0 to Count - 1 do begin
      sl.AddStrings(Items[i]);
      sl.Add(CMD_SEP_CHARS);
    end;  
    sl.SaveToFile(FileName);
  finally
    sl.Free;
  end;
end;

procedure TSqlHistory.SetItem(Index: Integer; AObject: TStrings);
begin
  inherited SetItem(Index, AObject);
end;


{ Routines }

procedure DelEmptyLines(S: TStrings);
var i: integer;
begin
  i := 0;
  while i <= S.Count - 1 do begin
    if Trim(S[i]) = '' then
      S.Delete(i)
    else
      i := i + 1;
  end;
end;

function GetCommaSpaceText(AStrings: TStrings; AQuote: string): string;
var
  S: string;
  I, Count: Integer;
begin
  Count := AStrings.Count;
  if (Count = 1) and (AStrings[0] = '') then
    Result := '""'
  else
  begin
    Result := '';
    for I := 0 to Count - 1 do
    begin
      S := AStrings[I];
      Result := Result + AQuote + S;
      if AQuote <> ':' then
        result := result + AQuote;
      result := result + ', ';
    end;
    System.Delete(Result, Length(Result) - 1, 2);
  end;
end;

function GetFieldDefList(ADataSet: TDataSet): string;
var
  i: integer;
  FieldName: string;

begin
  result := '';
  with ADataSet do
    for i := 0 to FieldDefList.Count - 1 do begin
      FieldName := FieldDefList.Strings[i];
      //if FieldName = 'SUM' then
      if CompareText(FieldName, 'ID') <> 0 then begin
        FieldName := '"' + FieldName + '"';
        result := result + FieldName;
        if i < FieldDefList.Count - 1 then
          result := result + ', ';
      end;
    end;
end;

function IbGetFieldList(IbSql: TIBSQL): string;
var i: integer;
begin
  //for i := 0 to IbSql.Current.Count - 1 do
    result := IbSql.Current.Names;
end;

procedure LoadSqlHistory(const FileName: string; Dest: TStrings);
var
  sl: TStringList;
  i: integer;
  s, CurCmd: string;
begin
  sl := TStringList.Create;
  sl.LoadFromFile(FileName);
  CurCmd := '';
  for i := 0 to sl.Count - 1 do begin
    s := Trim(sl[i]);
    CurCmd := CurCmd + s;
    if s <> '' then
      if s[Length(s)] = ';' then begin
        Dest.Add(CurCmd);
        CurCmd := '';
      end
      else
        CurCmd := CurCmd + #13#10;
  end;
  sl.Free;
end;

function CommandType(const Cmd: string): TCmdType;
var s: string;
begin
  result := ctUnknown;
  s := AnsiUpperCase(TrimLeft(Cmd));
  s := Copy(s, 1, Pos(' ', s) - 1);
  if s = 'SELECT' then begin
    if Pos('FROM', Cmd) > 0 then
      result := ctSelect;
  end
  else if s = 'UPDATE' then
    result := ctUpdate
  else if s = 'INSERT' then
    result := ctInsert
  else if s = 'DELETE' then
    result := ctDelete
  else if (s = 'CREATE') or (s = 'ALTER') then
    result := ctDDL
  else
    result := ctUnknown;
end;

function BuildSelect(const TableName: string): string;
begin
  result := Format('SELECT * FROM %s', [TableName]);
end;

procedure BuildInsert(ADataSet: TDataSet; Dest: TStrings);
var
  i: integer;
begin
  Dest.Clear;
  with ADataSet do
    for i := 0 to Fields.Count - 1 do begin
      case Fields[i].DataType of
        ftString, ftWideString, ftDate, ftDateTime:
          Dest.Add('''' + Trim(Fields[i].AsString) + '''');
        ftBoolean:
          Dest.Add(arrBoolVals[Fields[i].AsBoolean]);
        else
          Dest.Add(Fields[i].AsString);
      end;
    end;
end;

function FoxStrictDate(ADate: TDateTime): string;
var y, m, d: word;
begin
  DecodeDate(ADate, y, m, d);
  if (y + m + d) = 0 then
    result := '{}'
  else
    result := Format('{^%.4d-%.2d-%.2d}', [y, m, d]);
end;


function BuildFoxValues(ADataSet: TDataSet; Flds: string): string;
begin
  result := BuildValues(ADataSet, Flds, True);
end;

function BuildValues(ADataSet: TDataSet; Flds: string; FoxData: boolean;
                     AData: TStrings): String;
var
  i: integer;
  Dest, slFlds: TsmStringList;
  fld: TField;

  procedure AddValue;
  begin
    if fld = nil then
      Exit;
    case fld.DataType of
      ftString, ftWideString, ftDate, ftDateTime:
        Dest.Add('''' + Trim(fld.AsString) + '''');
      ftBoolean:
        Dest.Add(arrBoolVals[fld.AsBoolean]);
      ftSmallint, ftInteger, ftFloat, ftCurrency, ftBCD:
        if fld.IsNull then
          Dest.Add('null')
        else
          Dest.Add(fld.AsString)
      else
        Dest.Add(fld.AsString);
    end;
  end;

  procedure AddFoxValue;
  begin
    if fld = nil then
      Exit;
    case fld.DataType of
      ftString, ftWideString:
        Dest.Add('''' + fld.AsString + '''');
      ftDate, ftDateTime:
        Dest.Add(FoxStrictDate(fld.AsDateTime));
      ftBoolean:
        Dest.Add(FoxBools[fld.AsBoolean]);
      else
        Dest.Add(fld.AsString);
    end;
  end;

begin
  Dest := TsmStringList.Create;
  slFlds := TsmStringList.create;
  try
    slFlds.Delimiter := ',';
    slFlds.setDelimText(Flds);
    if slFlds.Count > 0 then begin
      for i := 0 to slFlds.Count - 1 do begin
        slFlds[i] := StringReplace(slFlds[i], '"', '', [rfReplaceAll]);
        fld := ADataSet.FindField(slFlds[i]);
        if FoxData then AddFoxValue
        else AddValue;
      end;
    end
    else begin
      for i := 0 to ADataSet.FieldCount - 1 do begin
        fld := ADataSet.Fields[i];
        AddValue;
      end;
    end;
    result := GetCommaSpaceText(Dest);
  finally
    Dest.Free;
    slFlds.Free;
  end;
end;

procedure ExtractDataAsSql(Src: TDataSet; DestTable: string;
            OutStrings: TStrings; AdditionalData: string);
const
  SQL_INSERT = 'INSERT INTO %s (%s) VALUES (%s);';
var
  flds, vals: string;
  AData: TsmStringList;
  i: integer;
begin
  AData := TsmStringList.create;
  try
    AData.setDelimText(AdditionalData);
    flds := '';
    for i := 0 to AData.Count - 1 do
        flds := flds + AData.Names[i] + ', ';
    flds := flds + GetFieldDefList(Src);
    OutStrings.Clear;
    Src.First;
    while not Src.Eof do begin
      vals := BuildValues(Src, flds);
      OutStrings.Add(Format(SQL_INSERT, [DestTable, flds, vals]));
      Src.Next;
    end;
  finally
    AData.Free;
  end;
end;

procedure ExtractDataAsSql(Src: TDataSet; DestTable: string;
            OutFile: string; AdditionalData: string); overload;
var sl: TStringList;
begin
  sl := TStringList.Create;
  try
    ExtractDataAsSql(Src, DestTable, sl);
    sl.SaveToFile(OutFile);
  finally
    sl.Free;
  end;
end;

procedure ExtractIbData(Db: TIBDataBase; aSQL: string; DestFile: string);
var
  ibSql: TIBSQL;
  tr: TIBTransaction;
  output: TIBOutputDelimitedFile;
begin
    {flds := GetFieldDefList(Src);
    while not Src.Eof do begin
      vals := BuildValues(Src, flds);
      OutStrings.Add(Format(SQL_INSERT, [DestTable, flds, vals]));
      Src.Next;
    end;}
  ibSql := TIBSQL.Create(Db);
  tr := TIBTRansaction.Create(Db);
  tr.DefaultDatabase := db;
  ibSql.Transaction := tr;

  ibSql.SQL.Text := aSQL;
  tr.StartTransaction;
  //ibSql.ExecQuery;

  output := TIBOutputDelimitedFile.Create;
  output.Filename := DestFile;
  output.OutputTitles := True;
  ibSql.BatchOutput(output);

  tr.Commit;
  output.Free;
  tr.Free;
  ibsql.Free;
end;

function ExtractTableName(CommandText: string): string;
var
  s : string;
  i: integer;
begin
  s := UpperCase(CommandText);
  i := Pos(' FROM ', s);
  Delete(s, 1, i + 5);
  i := 1;
  while not( s[i] in [' ', #13, #10] )
    and ( i <= length( s ) )
  do begin
    i := i + 1;
  end;
  if i = 0 then i := Length(s) + 1;
  result := Copy(s, 1, i - 1);
  result := StringReplace(result, #13, '', [rfReplaceAll]);
  result := StringReplace(result, #10, '', [rfReplaceAll]);
end;

procedure SetWhereClause(SQL: TStrings; WhereClause: string);
var
  i: integer;
begin
  for i := 0 to SQL.Count - 1 do
    if (Pos('/*', SQL[i]) > 0) and (Pos('WHERE ', UpperCase(SQL[I])) > 0) then
      SQL[i] := '/* WHERE */' + WhereClause;
end;

end.
